home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / unit.com / UNIT.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1988-12-10  |  9.6 KB  |  338 lines
  1. (*  UNIT  Copyright (C) 1988  BTS Software
  2.  
  3.     Written by Larry Johnson  12/09/88
  4.                BTS Software
  5.                825 Acton Ave
  6.                Birmingham, AL  35209
  7.                CompuServe: 73717,14
  8.                       BIX: lajohnson
  9.  
  10.     This program manages the procedure/function decelarations
  11.     in the interface section of a unit by copying specified
  12.     procedure/function headers from the implementation section
  13.     into the interface section.
  14.  
  15.     Usage: C>UNIT filename
  16.  
  17.      Insert these codes in your Unit:
  18.        {.I+} - start of procedure/function interface
  19.        {.I-} - end   of procedure/function interface
  20.        {.U+} - include this procedure/function in interface
  21.        {.U-} - stop including
  22.  
  23.     This program has a few limitations.  If the keywords BEGIN, VAR,
  24.     CONST, or TYPE appear in a comment following the declaration then
  25.     the transfer to the interface will stop.  Also these keywords should
  26.     have at least one space after them or use the {.U-} switch.  These
  27.     limitations could be overcome by writing a parser that ignores anything
  28.     in comments but until such a time you'll have to settle for the trade off.
  29.     It also won't process include files.  All code to be interfaced must be
  30.     in the same physical unit file. Enjoy.
  31.  
  32.     Note: type, const, & var should NOT be placed between the {.I+}/{.I-}
  33.           section; They will be erased!!!  {U+} moves procedure/function
  34.           headers only; no data declariations.
  35.  
  36.     ****  An Example  ****
  37.  
  38.     {-------------------------}
  39.  
  40.     Before:
  41.  
  42.       unit Sample ;
  43.  
  44.       interface
  45.  
  46.       {.I+} {Start of interface}
  47.       {.I-} {End   of interface}
  48.       implementation
  49.  
  50.       {.U+} {Include this procedure in the interface}
  51.       procedure Global(P1, P2 : word) ;
  52.         begin
  53.         end ;
  54.  
  55.       {.U-} {Don't Include this procedure in the interface}
  56.       procedure UnitLocal(P1, P2 : word) ;
  57.         begin
  58.         end ;
  59.  
  60.     {-------------------------}
  61.  
  62.     After C>Unit Sample.pas:
  63.  
  64.       unit Sample ;
  65.  
  66.       interface
  67.  
  68.       {.I+} {Start of interface}
  69. New>
  70. New>  procedure Global(P1, P2 : word) ;
  71. New>
  72.       {.I-} {End   of interface}
  73.       implementation
  74.  
  75.       {.U+} {Include this procedure in the interface}
  76.       procedure Global(P1, P2 : word) ;
  77.         begin
  78.         end ;
  79.  
  80.       {.U-} {Don't Include this procedure in the interface}
  81.       procedure UnitLocal(P1, P2 : word) ;
  82.         begin
  83.         end ;
  84.  
  85.   %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
  86.  
  87. {$D-} { Debug information (Global)   }
  88. {$L-} { Debug Local Symbols (Global) }
  89. {$A-} { Align Data (Global)          }
  90. {$E-} { 8087 Emulation (Global)      }
  91. {$N-} { Numeric CoProcessor (Global) }
  92. {$O-} { Overlay Code (Global)        }
  93. {------------------------------------}
  94. {$B-} { Boolean evaluation           }
  95. {$F-} { Force Far Calls              }
  96. {$I-} { I/O checking                 }
  97. {$R-} { Range checking               }
  98. {$S-} { Stack checking               }
  99. {$V-} { Var-String checking          }
  100.  
  101. {$M $4000,0,$A0000}  { Memory Allocation Sizes (MinStack,MinHeap,MaxHeap)}
  102.  
  103. { %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% }
  104.  
  105. program _Unit ;
  106.  
  107. { %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% }
  108.  
  109. const
  110.   ProgramName = 'UNIT' ;
  111.   Version     = '1.0F' ;
  112.   Compiled    = '12/09/88' ;
  113.  
  114. const
  115.   InterfaceStart  = '.I+' ;  {Mark the Start of the interface area}
  116.   InterfaceEnd    = '.I-' ;  {Mark the End   of the interface area}
  117.   IncludeOn       = '.U+' ;  {Mark procedure/function to be interfaced}
  118.   IncludeOff      = '.U-' ;  {Stop interfacing}
  119.  
  120. const
  121.   TextBufSize = 8192 ;  { Needs to be divisible by 128 }
  122.  
  123. var
  124.   InFile       : text ;
  125.   OutFile      : text ;
  126.   TmpFile      : text ;
  127.  
  128.   InBuf        : array[1..TextBufSize] of char ;
  129.   OutBuf       : array[1..TextBufSize] of char ;
  130.   TmpBuf       : array[1..TextBufSize] of char ;
  131.  
  132.   InFileName   : string[64] ;
  133.   OutFileName  : string[64] ;
  134.   TmpFileName  : string[64] ;
  135.  
  136.   LineIn       : string ;
  137.   UCLineIn     : string ;
  138.   TLineIn      : string ;
  139.  
  140.   SemiColon    : boolean ;
  141.   Writing      : boolean ;
  142.   CheckForCode : boolean ;
  143.   BlankLine    : boolean ;
  144.  
  145. { %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% }
  146.  
  147. function UpString(Wstr : string): string ;
  148.   var loop : byte ;
  149.   begin
  150.     for loop := 1 to length(Wstr) do
  151.       Wstr[loop] := UpCase(Wstr[loop]) ;
  152.     UpString := Wstr ;
  153.   end ;
  154.  
  155. function DefExt(FileName, Ext : string): string ;
  156.   begin
  157.     if (pos('.', FileName) > 0)
  158.       then DefExt := FileName
  159.       else DefExt := FileName + '.' + Ext ;
  160.   end;
  161.  
  162. function ForceExt(FileName, Ext : string): string ;
  163.   var Dot : byte ;
  164.   begin
  165.     Dot := pos('.', FileName) ;
  166.     if (Dot > 0)
  167.       then ForceExt := copy(FileName, 1, Dot) + Ext
  168.       else ForceExt := FileName + '.' + Ext ;
  169.   end;
  170.  
  171. { %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% }
  172.  
  173. function Contains(S : string): boolean ;
  174.   begin
  175.     Contains := (pos(S, UCLineIn) > 0) ;   {global}
  176.   end ;
  177.  
  178. procedure WritingOn ;
  179.   begin
  180.     Writing      := true ;   {global}
  181.     SemiColon    := true ;   {global}
  182.     CheckForCode := false ;  {global}
  183.     BlankLine    := true ;   {global}
  184.   end ;
  185.  
  186. procedure WritingOff ;
  187.   begin
  188.     if Writing and
  189.        BlankLine
  190.       then writeln(OutFile) ;  { make sure there is at least one blank line }
  191.     Writing := false ;  {global}
  192.   end ;
  193.  
  194. { %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% }
  195.  
  196. begin
  197.   writeln(#13, #10, ' ', ProgramName, '  V', Version, '  ', Compiled,
  198.                     '   Copyright (C) 1988  BTS Software', #13, #10) ;
  199.  
  200.   if (paramcount < 1) then  { Help }
  201.     begin
  202.       writeln(' This program updates the procedure/function declarations') ;
  203.       writeln(' in the interface of a unit based upon its implementation.') ;
  204.       writeln ;
  205.       writeln(' Usage: C>UNIT filename') ;
  206.       writeln ;
  207.       writeln('  Insert these codes in your Unit:') ;
  208.       writeln('    {' + InterfaceStart + '} - start of procedure/function interface') ;
  209.       writeln('    {' + InterfaceStart + '} - end   of procedure/function interface') ;
  210.       writeln('    {' + IncludeOn      + '} - include this procedure/function in interface') ;
  211.       writeln('    {' + IncludeOff     + '} - stop including') ;
  212.       halt(0) ;
  213.     end ;
  214.  
  215.   InFileName  := UpString(DefExt(paramstr(1), 'PAS')) ;
  216.   OutFileName := ForceExt(InFileName, 'HDR') ;
  217.   TmpFileName := ForceExt(InFileName, 'TMP') ;
  218.  
  219.   assign(InFile,  InFileName) ;
  220.   assign(OutFile, OutFileName) ;
  221.   assign(TmpFile, TmpFileName) ;
  222.  
  223.   SetTextBuf(InFile,  InBuf) ;
  224.   SetTextBuf(OutFile, OutBuf) ;
  225.   SetTextBuf(TmpFile, TmpBuf) ;
  226.  
  227.   reset(InFile) ;
  228.   if (IOresult <> 0) then
  229.     begin
  230.       writeln(InFileName, ' not found!', ^G) ;
  231.       halt(0) ;
  232.     end ;
  233.  
  234.   rewrite(OutFile) ;
  235.   writeln(OutFile) ;  { Start off with a Blank Line }
  236.  
  237.   write('Reading ', InFileName) ;  { Keep the human informed }
  238.  
  239.   Writing := false ;
  240.   while not eof(InFile) do
  241.     begin
  242.       readln(InFile, LineIn) ;
  243.  
  244.       UCLineIn := ' ' + UpString(LineIn) + ' ' ;  { Add sentinels }
  245.  
  246.       if contains(IncludeOff)
  247.         then WritingOff ;
  248.  
  249.       if Writing and
  250.          CheckForCode and
  251.          (contains(' VAR ') or
  252.           contains(' CONST ') or
  253.           contains(' TYPE ') or
  254.           contains(' BEGIN '))
  255.         then WritingOff ;  { Stop if Code found }
  256.  
  257.       if Writing and
  258.          (BlankLine or
  259.           (length(LineIn) > 0))
  260.         then writeln(OutFile, LineIn) ;  { if Not Blank line then save }
  261.  
  262.       if Writing then
  263.         begin
  264.           BlankLine := (length(LineIn) > 0) ;
  265.  
  266.           if contains('(')
  267.             then SemiColon := false ;
  268.           if contains(')')
  269.             then SemiColon := true ;
  270.  
  271.           if SemiColon and
  272.              contains(';')
  273.             then CheckForCode := true ;
  274.         end ;
  275.  
  276.       if contains(IncludeOn)
  277.         then WritingOn ;  { turn writing on }
  278.     end ;
  279.  
  280.   close(OutFile) ;
  281.   close(InFile) ;
  282.  
  283.   write(#13, #10, 'Finding Interface') ;
  284.  
  285.   reset(InFile) ;
  286.   reset(OutFile) ;
  287.   rewrite(TmpFile) ;
  288.  
  289.   while not eof(InFile) do
  290.     begin
  291.       readln(InFile, LineIn) ;
  292.       writeln(TmpFile, LineIn) ;
  293.  
  294.       if (pos(InterfaceStart, UpString(LineIn)) > 0)
  295.         then
  296.           begin
  297.             write(#13, #10, 'Deleting Old Interface') ;
  298.             UCLineIn := '' ;
  299.             while not eof(InFile) and
  300.                   not contains(InterfaceEnd) and
  301.                   not contains('IMPLEMENTATION') do
  302.               begin
  303.                 readln(InFile, LineIn) ;
  304.                 UCLineIn := UpString(LineIn) ;
  305.               end ;
  306.  
  307.             write(#13, #10, 'Writing New Interface') ;
  308.  
  309.             while not eof(OutFile) do
  310.               begin
  311.                 readln(OutFile,  TLineIn) ;
  312.                 writeln(TmpFile, TLineIn) ;
  313.               end ;
  314.  
  315.             write(#13, #10, 'Copying Implementation') ;
  316.  
  317.             writeln(TmpFile, LineIn) ; { .I- or Implementation }
  318.           end ;
  319.     end ;
  320.  
  321.   close(InFile) ;
  322.   close(OutFile) ;
  323.   close(TmpFile) ;
  324.  
  325.   erase(OutFile) ;  { '*.HDR' }
  326.  
  327.   assign(OutFile, ForceExt(InFileName, 'BAK')) ;
  328.   erase(OutFile) ;  { '*.BAK' }
  329.   if (IOresult = 0) then {} ;  { there may not be a *.BAK file }
  330.  
  331.   rename(InFile,  ForceExt(InFileName, 'BAK')) ;  { '*.PAS' to '*.BAK' }
  332.   rename(TmpFile, InFileName) ;  { '*.TMP' to '*.PAS' }
  333.  
  334.   erase(InFile) ;  { '*.BAK' }
  335.   if (IOresult = 0) then {} ;  { OK to erase now... }
  336.  
  337.   writeln(#13, #10, '*** Done ***') ;  { tell 'sack of mostly water' we've finsihed }
  338. end.